home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / stklos.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-24  |  29.6 KB  |  983 lines
  1. /*
  2.  *
  3.  *  s t k l o s . c            -- STklos support
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *            Author: Erick Gallesio [eg@unice.fr]
  21.  *    Creation date:  9-Feb-1994 15:56
  22.  * Last file update: 24-Jul-1996 17:03 
  23.  */
  24.  
  25. #ifdef USE_STKLOS
  26.  
  27. #include "stk.h"
  28. #include "stklos.h"
  29.  
  30. #define CLASSP(x)        (INSTANCEP(x) && SUBCLASSP(CLASS_OF(x), Class))
  31. #define GENERICP(x)          (INSTANCEP(x) && SUBCLASSP(CLASS_OF(x), Generic))
  32. #define METHODP(x)          (INSTANCEP(x) && SUBCLASSP(CLASS_OF(x), Method))
  33.  
  34. #define NCLASSP(x)        (!CLASSP(x))
  35. #define NGENERICP(x)        (!GENERICP(x))
  36. #define NMETHODP(x)          (!METHODP(x))
  37.  
  38. #define SPEC_OF(x)        THE_SLOT_OF(x, S_specializers)
  39.  
  40.  
  41. static char k_initform[]     = ":initform";     /* In a var so it can be */
  42. static char k_init_keyword[] = ":init-keyword"; /* patched by STk_makekey */
  43.  
  44. static SCM Top, Object, Class, Generic, Method, Procedure_class, Entity_class;
  45. static SCM Boolean, Char, Pair, Procedure, String, Symbol, Vector, Number, 
  46.        List, Null, Real, Integer, Keyword, Unknown;
  47. #ifdef USE_TK
  48. static SCM Widget;
  49. #endif
  50.  
  51. static void slot_set_if_unbound(SCM obj, SCM slot_name, SCM value);
  52.  
  53. /*****************************************************************************/
  54.  
  55. static SCM make_instance(SCM classe, long  size, int type)
  56. {
  57.   register SCM z;
  58.   register long i;
  59.  
  60.   NEWCELL(z, STk_tc_instance);
  61.   INST(z)          = must_malloc(sizeof(Instance) + (size-1)*sizeof(SCM));
  62.  
  63.   CLASS_OF(z)        = classe;
  64.   INST_TYPE(z)         = type;
  65.   ACCESSORS_OF(z)    = classe? THE_SLOT_OF(classe, S_getters_n_setters) : NIL;
  66.   NUMBER_OF_SLOTS(z) = size;
  67.  
  68.   /* Set all the slots to unbound */
  69.   for (i = 0; i < size; i++)
  70.     THE_SLOT_OF(z, i) = UNBOUND;
  71.  
  72.   return z;
  73. }
  74.  
  75. /******************************************************************************
  76.  *
  77.  * compute-cpl
  78.  *
  79.  *   This version doesn't handle multiple-inheritance. It serves only for
  80.  * booting classes and will be overaloaded in Scheme
  81.  *
  82.  ******************************************************************************/
  83.  
  84. static SCM compute_cpl(SCM supers, SCM res)
  85. {
  86.   return NULLP(supers)? Reverse(res)
  87.                   : compute_cpl(THE_SLOT_OF(CAR(supers), S_direct_supers),
  88.                      Cons(CAR(supers), res));
  89. }
  90.  
  91. /******************************************************************************
  92.  *
  93.  * compute-slots
  94.  *
  95.  ******************************************************************************/
  96.  
  97. static SCM remove_duplicate_slots(SCM l, SCM res, SCM slots_already_seen)
  98. {
  99.   SCM tmp;
  100.  
  101.   if (NULLP(l)) return res;
  102.  
  103.   tmp = CONSP(CAR(l)) ? CAR(CAR(l)) : CAR(l);
  104.   if (NSYMBOLP(tmp)) Err("%compute-slots: bad slot name", tmp);
  105.   
  106.   if (STk_memq(tmp, slots_already_seen) == Ntruth) {
  107.     res            = Cons(CAR(l), res);
  108.     slots_already_seen = Cons(tmp, slots_already_seen);
  109.   }
  110.   
  111.   return remove_duplicate_slots(CDR(l), res, slots_already_seen);
  112. }
  113.  
  114. static SCM build_slots_list(SCM dslots, SCM cpl)
  115. {
  116.   register SCM res = dslots;
  117.  
  118.   for (cpl = CDR(cpl); NNULLP(cpl); cpl = CDR(cpl))
  119.     res = STk_append(LIST2(THE_SLOT_OF(CAR(cpl), S_direct_slots), res), 2);
  120.  
  121.   /* res contains a list of slots. Remove slots which appears more than once */
  122.   return remove_duplicate_slots(Reverse(res), NIL, NIL);
  123. }
  124.  
  125.  
  126. static PRIMITIVE compute_slots(SCM classe)
  127. {
  128.   if (NCLASSP(classe)) Err("compute-class: bad class", classe);
  129.   return build_slots_list(THE_SLOT_OF(classe, S_direct_slots),
  130.               THE_SLOT_OF(classe, S_cpl));
  131. }
  132.  
  133. /******************************************************************************
  134.  *
  135.  * compute-getters-n-setters
  136.  *  
  137.  *   This version doesn't handle slot options. It serves only for booting 
  138.  * classes and will be overaloaded in Scheme.
  139.  *
  140.  ******************************************************************************/
  141.  
  142. static SCM compute_getters_n_setters(SCM slots)
  143. {
  144.   SCM  res = NIL;
  145.   long i   = 0;
  146.  
  147.   for (  ; NNULLP(slots); slots = CDR(slots)) 
  148.     res = Cons(Cons(CAR(slots),STk_makeinteger(i++)), res);
  149.  
  150.   return res;
  151. }
  152.  
  153. /******************************************************************************
  154.  *
  155.  * compute-initializers
  156.  *
  157.  ******************************************************************************/
  158.  
  159. static SCM build_initializers(SCM slots)
  160. {
  161.   SCM initform, tmp, curr_slot, res = NIL;
  162.  
  163.   for ( ; NNULLP(slots); slots = CDR(slots)) {
  164.     tmp       = NIL;
  165.     curr_slot = CAR(slots);
  166.  
  167.     if (CONSP(curr_slot)) {    
  168.       /* slot is a pair. See if an :initform is provided */
  169.       if (STk_llength(curr_slot) > 1) {
  170.     initform = STk_get_keyword(STk_makekey(k_initform),CDR(curr_slot),NULL);
  171.     if (initform)
  172.       tmp = STk_eval(LIST3(Sym_lambda, NIL, initform), NIL);
  173.       }
  174.     }
  175.     res = Cons(tmp, res);
  176.   }
  177.   return Reverse(res);
  178. }
  179.  
  180. /******************************************************************************
  181.  *
  182.  * initialize-object
  183.  *
  184.  ******************************************************************************/
  185.  
  186. static PRIMITIVE initialize_object(SCM obj, SCM initargs)
  187. {
  188.   SCM tmp, initializers, slots;
  189.  
  190.   if (NINSTANCEP(obj))
  191.     Err("%initialize-object: bad instance", obj);
  192.   if (NCONSP(initargs) && NNULLP(initargs)) 
  193.     Err("%initialize-object: bad init list", initargs);
  194.   
  195.   initializers = THE_SLOT_OF(CLASS_OF(obj), S_initializers);
  196.   slots        = THE_SLOT_OF(CLASS_OF(obj), S_slots);
  197.   
  198.   /* See for each slot how it must be initialized */
  199.   for ( ; NNULLP(initializers); initializers=CDR(initializers), slots=CDR(slots)) {
  200.     SCM slot_name  = CAR(slots);
  201.     SCM slot_value = NULL;
  202.     
  203.     if (CONSP(slot_name)) {
  204.       /* This slot admits (perhaps) to be initialized at creation time */
  205.       tmp     = STk_get_keyword(STk_makekey(k_init_keyword),CDR(slot_name), NULL);
  206.       slot_name = CAR(slot_name);
  207.       if (tmp) {
  208.     /* an initarg was provided for this slot */
  209.     if (NKEYWORDP(tmp))
  210.       Err("%initialize-object: initarg must be a keyword. It was", tmp);
  211.     slot_value = STk_get_keyword(tmp, initargs, NULL);
  212.       }
  213.     }
  214.  
  215.     if (slot_value)
  216.       /* set slot to provided value */
  217.       STk_slot_set(obj, slot_name, slot_value);
  218.     else 
  219.       /* set slot to its :initform if it exists */
  220.       if (NNULLP(CAR(initializers)))
  221.     slot_set_if_unbound(obj, slot_name, Apply(CAR(initializers), NIL));
  222.   }
  223.   
  224.   return obj;
  225. }
  226.  
  227. /******************************************************************************/
  228.  
  229. SCM STk_basic_make_class(SCM classe, SCM name, SCM dsupers, SCM dslots)
  230. {
  231.   SCM z, cpl, slots, g_n_s;
  232.  
  233.   /* Allocate one instance */
  234.   z     = make_instance(classe, NUMBER_OF_CLASS_SLOTS, TYPE_INSTANCE);
  235.  
  236.   /* Initialize its slots */
  237.   cpl   = compute_cpl(dsupers, LIST1(z));
  238.   slots = build_slots_list(dslots, cpl);
  239.   g_n_s = compute_getters_n_setters(slots);
  240.  
  241.   THE_SLOT_OF(z, S_name)          = name;
  242.   THE_SLOT_OF(z, S_direct_supers)     = dsupers;
  243.   THE_SLOT_OF(z, S_direct_slots)      = dslots;
  244.   THE_SLOT_OF(z, S_cpl)              = cpl;
  245.   THE_SLOT_OF(z, S_slots)          = slots;
  246.   THE_SLOT_OF(z, S_nfields)          = STk_makeinteger(STk_llength(slots));
  247.   THE_SLOT_OF(z, S_getters_n_setters) = g_n_s;
  248.   THE_SLOT_OF(z, S_initializers)      = build_initializers(slots);
  249.  
  250.   /* Don't forget to set the accessors list of the object */
  251.   ACCESSORS_OF(z) = THE_SLOT_OF(classe, S_getters_n_setters);
  252.   
  253.   return z;
  254. }
  255.  
  256. /******************************************************************************/
  257.  
  258. static void create_Top_Object_Class(void)
  259. {
  260.   SCM tmp, slots_of_class = LIST8(Intern("name"), 
  261.                   Intern("direct-supers"),
  262.                   Intern("direct-slots"),
  263.                   Intern("cpl"),
  264.                   Intern("slots"),
  265.                   Intern("nfields"),
  266.                   Intern("initializers"),
  267.                   Intern("getters-n-setters"));
  268.  
  269.   /**** <Class> ****/
  270.   tmp     = Intern("<class>");
  271.   Class = make_instance(NULL, NUMBER_OF_CLASS_SLOTS, TYPE_INSTANCE);
  272.  
  273.   CLASS_OF(Class)     = Class;
  274.   ACCESSORS_OF(Class) = compute_getters_n_setters(slots_of_class);
  275.  
  276.   THE_SLOT_OF(Class, S_name)           = tmp;
  277.   THE_SLOT_OF(Class, S_direct_supers)      = NIL; /* will be changed */
  278.   THE_SLOT_OF(Class, S_direct_slots)      = slots_of_class;
  279.   THE_SLOT_OF(Class, S_cpl)          = NIL;  /* will be changed */
  280.   THE_SLOT_OF(Class, S_slots)          = slots_of_class;
  281.   THE_SLOT_OF(Class, S_nfields)          = STk_makeinteger(NUMBER_OF_CLASS_SLOTS);
  282.   THE_SLOT_OF(Class, S_initializers)      = build_initializers(slots_of_class);
  283.   THE_SLOT_OF(Class, S_getters_n_setters) = ACCESSORS_OF(Class);
  284.  
  285.   VCELL(tmp) = Class;
  286.  
  287.   /**** <Top> ****/
  288.   tmp = Intern("<top>");
  289.   Top = STk_basic_make_class(Class, tmp, NIL, NIL);
  290.  
  291.   VCELL(tmp) = Top;
  292.   
  293.   /**** <Object> ****/
  294.   tmp     = Intern("<object>");
  295.   Object = STk_basic_make_class(Class, tmp, LIST1(Top), NIL);
  296.  
  297.   VCELL(tmp) = Object;
  298.  
  299.   /* <top> <object> and <class> were partly uninitialized. Correct them here */
  300.   THE_SLOT_OF(Class, S_direct_supers)   = LIST1(Object);
  301.   THE_SLOT_OF(Class, S_cpl)        = LIST3(Class, Object, Top);
  302.  
  303.   /* protect Top, Object and Class  against garbage collection */
  304.   STk_gc_protect(&Top);
  305.   STk_gc_protect(&Object);
  306.   STk_gc_protect(&Class);
  307. }
  308.  
  309. /******************************************************************************/
  310.  
  311. static PRIMITIVE instancep(SCM obj)
  312. {
  313.   return INSTANCEP(obj)? Truth: Ntruth;
  314. }
  315.  
  316. PRIMITIVE STk_class_of(SCM obj)
  317. {
  318.   if (INSTANCEP(obj)) return CLASS_OF(obj);
  319.  
  320.   switch (TYPE(obj)) {
  321.     case tc_boolean:    return Boolean;
  322.     case tc_char:    return Char;
  323.     case tc_cons:    return Pair;
  324.     case tc_nil:    return Null;
  325.     case tc_string:    return String;
  326.     case tc_symbol:    return Symbol;
  327.     case tc_vector:    return Vector;
  328.     case tc_flonum:    return Real;
  329.     case tc_integer:
  330.     case tc_bignum:    return Integer;
  331.     case tc_keyword:    return Keyword;
  332. #ifdef USE_TK
  333.     case tc_tkcommand:    return Widget;
  334. #endif
  335.     default:         return (STk_procedurep(obj) == Truth)? Procedure: Unknown;
  336.   }
  337. }
  338. static PRIMITIVE class_name(SCM obj)
  339. {
  340.   if (NINSTANCEP(obj)) Err("class-name: bad class", obj);
  341.   return STk_slot_ref(obj, Intern("name"));
  342. }
  343. static PRIMITIVE class_direct_supers(SCM obj)
  344. {
  345.   if (NINSTANCEP(obj)) Err("class-direct-supers: bad class", obj);
  346.   return STk_slot_ref(obj, Intern("direct-supers"));
  347. }
  348. static PRIMITIVE class_direct_slots(SCM obj)
  349. {
  350.   if (NINSTANCEP(obj)) Err("class-direct-slots: bad class", obj);
  351.   return STk_slot_ref(obj, Intern("direct-slots"));
  352. }
  353. static PRIMITIVE class_cpl(SCM obj)
  354. {
  355.   if (NINSTANCEP(obj)) Err("class-precedence-list: bad class", obj);
  356.   return STk_slot_ref(obj, Intern("cpl"));
  357. }
  358. static PRIMITIVE class_slots(SCM obj)
  359. {
  360.   if (NINSTANCEP(obj)) Err("class-slots: bad class", obj);
  361.   return STk_slot_ref(obj, Intern("slots"));
  362. }
  363.  
  364. static PRIMITIVE slot_existsp(SCM obj, SCM slot_name)
  365. {
  366.   if (NSYMBOLP(slot_name)) Err("slot-exists?: bad slot name", slot_name);
  367.   if (NINSTANCEP(obj))     Err("slot-exists?: bad object", obj);
  368.   return STk_assq(slot_name, ACCESSORS_OF(obj)) == Ntruth ? Ntruth : Truth;
  369. }
  370.  
  371.  
  372. /******************************************************************************
  373.  *
  374.  * slot-ref, slot-set! and slot-bound?
  375.  *
  376.  ******************************************************************************/
  377.  
  378. PRIMITIVE STk_slot_ref(SCM obj, SCM slot_name)
  379. {
  380.   register SCM entry;
  381.   SCM res;
  382.  
  383.   if (NINSTANCEP(obj)) Err("slot-ref: bad instance", obj);
  384.   
  385.   entry = STk_assq(slot_name, ACCESSORS_OF(obj));
  386.   if (entry == Ntruth) 
  387.     Err("slot-ref: no slot with name", slot_name);
  388.  
  389.   /* Two cases here:
  390.    *    - if (cdr entry) is an integer (the offset of this slot in the slots vector
  391.    *    - otherwise (cadr entry) is the reader function to apply
  392.    */
  393.   res = INTEGERP(CDR(entry)) ? THE_SLOT_OF(obj, INTEGER(CDR(entry)))
  394.                      : Apply(STk_cadr(entry), LIST1(obj));
  395.   if (res == UNBOUND) Err("slot-ref: slot unbound", slot_name);
  396.  
  397.   return res;
  398. }
  399.  
  400. PRIMITIVE STk_slot_set(SCM obj, SCM slot_name, SCM value)
  401. {
  402.   register SCM entry;
  403.  
  404.   if (NINSTANCEP(obj)) Err("slot-set!: bad instance", obj);
  405.   
  406.   entry = STk_assq(slot_name, ACCESSORS_OF(obj));
  407.   if (entry == Ntruth) 
  408.     Err("slot-set!: no slot with name", slot_name);
  409.  
  410.   /* Two cases here:
  411.    *    - if (cdr entry) is an integer (the offset of this slot in the slots vector)
  412.    *    - otherwise (caddr entry) is the writer function to apply
  413.    */
  414.   if (INTEGERP(CDR(entry)))
  415.     THE_SLOT_OF(obj, INTEGER(CDR(entry))) = value;
  416.   else
  417.     Apply(STk_caddr(entry), LIST2(obj, value));
  418.  
  419.   return UNDEFINED;
  420. }
  421.  
  422. static PRIMITIVE slot_boundp(SCM obj, SCM slot_name)
  423. {
  424.   register SCM entry;
  425.   SCM res;
  426.  
  427.   if (NINSTANCEP(obj)) Err("slot-bound?: bad instance", obj);
  428.   
  429.   entry = STk_assq(slot_name, ACCESSORS_OF(obj));
  430.   if (entry == Ntruth) 
  431.     Err("slot-bound?: no slot with name", slot_name);
  432.  
  433.   res = INTEGERP(CDR(entry)) ? THE_SLOT_OF(obj, INTEGER(CDR(entry)))
  434.                      : Apply(STk_cadr(entry), LIST1(obj));
  435.  
  436.   return (res == UNBOUND) ? Ntruth : Truth;
  437. }
  438.  
  439. static void slot_set_if_unbound(SCM obj, SCM slot_name, SCM value)
  440. {
  441.   register SCM entry;
  442.  
  443.   if ((entry = STk_assq(slot_name, ACCESSORS_OF(obj))) == Ntruth) return;
  444.  
  445.   if (INTEGERP(CDR(entry))) {
  446.     if (THE_SLOT_OF(obj, INTEGER(CDR(entry))) == UNBOUND)
  447.       THE_SLOT_OF(obj, INTEGER(CDR(entry))) = value;
  448.   }
  449.   else {
  450.     if (Apply(STk_cadr(entry), LIST1(obj)) == UNBOUND)
  451.       Apply(STk_caddr(entry), LIST2(obj, value));
  452.   }
  453. }
  454.  
  455. /******************************************************************************
  456.  *
  457.  * %allocate-instance (the low level instance allocation primitive)
  458.  *
  459.  ******************************************************************************/
  460.  
  461. PRIMITIVE STk_allocate_instance(SCM classe)
  462. {
  463.   if (NCLASSP(classe)) Err("%allocate-instance: bad class", classe);
  464.   return make_instance(classe, 
  465.                STk_integer_value(THE_SLOT_OF(classe, S_nfields)),
  466.                EQ(classe, Generic) ? TYPE_GENERIC : TYPE_INSTANCE);
  467. }
  468.  
  469. /******************************************************************************
  470.  *
  471.  * %modify-instance (used by change-class to modify in place)
  472.  * 
  473.  ******************************************************************************/
  474. static PRIMITIVE modify_instance(SCM old, SCM new)
  475. {
  476.   Instance *old_inst;
  477.  
  478.   if (NINSTANCEP(old) || NINSTANCEP(new)) 
  479.     Err("%modify-instance: both parameters must be instances", NIL);
  480.  
  481.   /* Exchange the data contained in old and new */
  482.   old_inst  = INST(old);
  483.   INST(old) = INST(new);
  484.   INST(new) = old_inst;
  485.     
  486.   return old;
  487. }
  488.  
  489. static PRIMITIVE stklos_version(void)
  490. {
  491.   return STk_makestring(STKLOS_VERSION);
  492. }
  493.  
  494. /******************************************************************************
  495.  *
  496.  *  GGGGG                FFFFF          
  497.  *  G                    F    
  498.  *  G  GG                FFF    
  499.  *  G   G                F      
  500.  *  GGGGG E N E R I C    F    U N C T I O N S
  501.  *
  502.  * This implementation provides
  503.  *    - generic functions (with class specializers)
  504.  *    - multi-methods
  505.  *    - next-method 
  506.  *    - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
  507.  *
  508.  ******************************************************************************/
  509.  
  510. SCM STk_make_next_method(SCM methods, SCM args)
  511. {
  512.   register SCM z;
  513.   
  514.   NEWCELL(z, tc_next_method);
  515.   CAR(z) = methods;
  516.   CDR(z) = args;
  517.   return z;
  518. }
  519.  
  520. SCM STk_apply_next_method(SCM next, SCM provided_args)
  521. {
  522.   SCM methods = CAR(next);
  523.   SCM args    = NULLP(provided_args)? CDR(next) : provided_args;
  524.  
  525.   if (NULLP(methods)) {
  526.     /* not very useful, but we cannot do bette for now*/
  527.     STk_err("no next-method  available", next); 
  528. #ifdef NYI
  529.     /* Ideal code */
  530.     SCM gf = ????? /* Hard to find the gf at minimal cost. Need more work */
  531.     return Apply(VCELL(Intern("no-next-method")), LIST2(gf, args));
  532. #endif
  533.   }
  534.   {
  535.     SCM m        = CAR(methods);
  536.     SCM new_next = STk_make_next_method(CDR(methods), args);
  537.  
  538.     /* m is the function to call with args. */
  539.     return Apply(THE_SLOT_OF(m, S_procedure), Cons(new_next, args));
  540.   }
  541. }
  542.  
  543. #ifdef NYI
  544.  
  545. This comment must be updated 
  546.  
  547. /******************************************************************************
  548.  * 
  549.  * Protocol for calling a generic fumction
  550.  *
  551.  *     + apply-generic (gf args)
  552.  *        + compute-applicable-methods (gf args)
  553.  *        + apply-methods (methods args)
  554.  *            + apply-method (method args next-methods)
  555.  *                
  556.  * apply-method calls make-next-method to build the "continuation" of a a method
  557.  * Calling a next-method will call apply-next-method which in turn will call 
  558.  * apply-method again to call effectively the following method.
  559.  *
  560.  ******************************************************************************/
  561. #endif
  562.  
  563. static int applicablep(SCM actual, SCM formal)
  564. {
  565.   register SCM ptr;
  566.  
  567.   /* We test that (memq formal (slot-ref actual 'cpl))
  568.    * However, we don't call memq here since we already know that
  569.    * the list is well formed 
  570.    */
  571.   for (ptr=THE_SLOT_OF(actual, S_cpl); NNULLP(ptr); ptr = CDR(ptr)) { 
  572.     if (CONSP(ptr)) {
  573.       if (EQ(CAR(ptr), formal)) return TRUE;
  574.     }
  575.     else 
  576.       Err("Internal error in applicable: bad list", actual);
  577.   }
  578.   return FALSE;
  579. }
  580.  
  581. static int more_specificp(SCM m1, SCM m2, SCM *targs)
  582. {
  583.   register SCM s1, s2;
  584.   register int i;
  585.   /* 
  586.    * Note: 
  587.    *   m1 and m2 can have != length (i.e. one can be one element longer than the 
  588.    * other when we have a dotted parameter list). For instance, with the call
  589.    *   (M 1)
  590.    * with
  591.    *   (define-method M (a . l) ....)
  592.    *   (define-method M (a) ....) 
  593.    *
  594.    * we consider that the second method is more specific.
  595.    *
  596.    * BTW, targs is an array of types. We don't need it's size since
  597.    * we already know that m1 and m2 are applicable (no risk to go past
  598.    * the end of this array).
  599.    *
  600.    */
  601.   for (i=0,s1=SPEC_OF(m1),s2=SPEC_OF(m2); ; i++,s1=CDR(s1),s2=CDR(s2)) {
  602.     if (NULLP(s1)) return 1;
  603.     if (NULLP(s2)) return 0;
  604.     if (CAR(s1) != CAR(s2)) {
  605.       register SCM l, cs1 = CAR(s1), cs2 = CAR(s2);
  606.       
  607.       for (l = THE_SLOT_OF(targs[i], S_cpl);   ; l = CDR(l)) {
  608.     if (EQ(cs1, CAR(l))) return 1;
  609.     if (EQ(cs2, CAR(l))) return 0;
  610.       }
  611.       return 0;/* should not occur! */
  612.     }
  613.   }
  614.   return 0; /* should not occur! */
  615. }
  616.  
  617. #define BUFFSIZE 32        /* big enough for most uses */
  618.  
  619. static SCM sort_applicable_methods(SCM method_list, int size, SCM *targs)
  620. {
  621.   int i, j, incr;
  622.   SCM *v, vector;
  623.   SCM buffer[BUFFSIZE];
  624.   SCM save = method_list;
  625.  
  626.   /* For reasonably sized method_lists we can try to avoid all the
  627.    * consing and reorder the list in place...
  628.    * This idea is due to David McClain <Dave_McClain@msn.com>
  629.    */
  630.   if (size <= BUFFSIZE) {
  631.     for(i=0;  i < size; i++) {
  632.       buffer[i]   = CAR(method_list);
  633.       method_list = CDR(method_list);
  634.     }
  635.     v = buffer;
  636.   } 
  637.   else {
  638.     /* Too many elements in method_list to keep everything locally */
  639.     vector = STk_vector(save, size);
  640.     v      = VECT(vector);
  641.   }
  642.  
  643.   /* Use a simple shell sort since it is generally faster than qsort on 
  644.    * small vectors (which is probably mostly the case when we have to
  645.    * sort a list of applicable methods).
  646.    */
  647.   for (incr = size / 2; incr; incr /= 2) {
  648.     for (i = incr; i < size; i++) {
  649.       for (j = i-incr ;j >= 0; j -= incr) {
  650.     if (more_specificp(v[j], v[j+incr], targs)) break;
  651.     else {
  652.       SCM tmp   = v[j+incr];
  653.       v[j+incr] = v[j];
  654.       v[j]        = tmp;
  655.     }
  656.       }
  657.     }
  658.   }
  659.  
  660.   if (size <= BUFFSIZE) {
  661.     /* We did it in locally, so restore the original list (reordered) in-place */
  662.     for(i=0, method_list=save; i < size; i++, v++) {
  663.       CAR(method_list) = *v;
  664.       method_list      = CDR(method_list);
  665.     }
  666.     return save;
  667.   }
  668.   /* If we are here, that's that we did it the hard way... */ 
  669.   return STk_vector2list(vector);
  670. }
  671.  
  672. SCM STk_compute_applicable_methods(SCM gf, SCM args, int len, int find_method)
  673. {
  674.   register int i;
  675.   int count = 0;
  676.   SCM l, fl, applicable = NIL;
  677.   SCM save = args;
  678.   SCM buffer[BUFFSIZE], *types, *p;
  679.   SCM tmp;
  680.  
  681.   /* Build the list of arguments types */
  682.   if (len >= BUFFSIZE) {
  683.     tmp   = STk_makevect(len, NULL);
  684.     types = p = VECT(tmp);
  685.   }
  686.   else
  687.     types = p = buffer;
  688.   
  689.   for (  ; NNULLP(args); args = CDR(args)) 
  690.     *p++ = STk_class_of(CAR(args));
  691.  
  692.   /* Build a list of all applicable methods */
  693.   for (l = THE_SLOT_OF(gf, S_methods); NNULLP(l); l = CDR(l)) {
  694.     for (i=0, fl=SPEC_OF(CAR(l));  ; i++, fl=CDR(fl)) {
  695.       if (INSTANCEP(fl) ||           /* We have a dotted argument list */
  696.       (i >= len && NULLP(fl))) {    /* both list exhausted */
  697.     applicable = Cons(CAR(l), applicable);
  698.     count     += 1;
  699.     break;
  700.       }
  701.       if (i >= len || NULLP(fl) || !applicablep(types[i], CAR(fl))) break;
  702.     }
  703.   }
  704.  
  705.   if (count == 0) {
  706.     if (find_method) return Ntruth;
  707.     Apply(VCELL(Intern("no-applicable-method")), LIST2(gf, save));
  708.     /* if we are here, it's because no-applicable-method hasn't signaled an error */
  709.     return NIL;
  710.   }
  711.   return (count == 1) ? applicable : 
  712.                 sort_applicable_methods(applicable, count, types);
  713. }
  714.  
  715.  
  716.  
  717. static SCM apply_method(SCM m, SCM args, SCM next_methods)
  718. {
  719.   return Apply(THE_SLOT_OF(m, S_procedure),
  720.            Cons(STk_make_next_method(next_methods, args), args));
  721. }
  722.  
  723. SCM STk_apply_methods(SCM methods, SCM args)
  724. {
  725.   if (NULLP(methods)) {
  726.     /* 
  727.      * methods can be NIL if we have a no-applicable-method handler which 
  728.      * doesn't signal an error (or dont ends with a call to next-method)
  729.      * In this case return an undefined value
  730.      */
  731.     return UNDEFINED;
  732.   }
  733.  
  734.   return apply_method(CAR(methods), args, CDR(methods));
  735. }
  736.  
  737. SCM STk_apply_generic(SCM gf, SCM args)
  738. {
  739.   if (NGENERICP(gf)) Err("apply: bad generic function", gf);
  740.   if (NULLP(THE_SLOT_OF(gf, S_methods))) 
  741.     Err("apply: no method for generic", gf);
  742.  
  743.   return STk_apply_methods(
  744.            STk_compute_applicable_methods(gf, args, STk_llength(args), FALSE),
  745.        args);
  746. }
  747.  
  748.  
  749. SCM STk_apply_user_generic(SCM gf, SCM args)
  750. {
  751.   if (NGENERICP(gf)) STk_err("apply: bad generic function", gf);
  752.   return Apply(VCELL(Intern("apply-generic")), LIST2(gf, args));
  753. }
  754.  
  755.  
  756. /******************************************************************************
  757.   *
  758.   * add-method
  759.   *
  760.   *******************************************************************************/
  761.  
  762. static SCM compute_new_list_of_methods(SCM gf, SCM new)
  763. {
  764.   SCM l1, l2, l;
  765.   SCM new_spec = SPEC_OF(new);
  766.   SCM methods  = THE_SLOT_OF(gf, S_methods);
  767.  
  768.   for (l = methods; NNULLP(l); l = CDR(l)) {
  769.     for (l1=new_spec, l2=SPEC_OF(CAR(l));    ; l1=CDR(l1), l2=CDR(l2)) {
  770.       if (NULLP(l1) && NULLP(l2)) {
  771.     /* The spec. list of new method already exists in the gf mehods list */    
  772.     CAR(l) = new;
  773.     return methods;
  774.       }
  775.       if (NULLP(l1) || NULLP(l2) || NEQ(CAR(l1), CAR(l2))) break;
  776.     }
  777.   }
  778.  
  779.   /* If we are here, we have not encountered a method with same specializers */
  780.   return Cons(new, methods);
  781. }
  782.  
  783.  
  784. static PRIMITIVE add_method(SCM gf, SCM method)
  785. {
  786.   if (NGENERICP(gf))    Err("add-method: bad generic function", gf); 
  787.   if (NMETHODP(method)) Err("add-method: bad method", method);
  788.   
  789.   THE_SLOT_OF(gf, S_methods) = compute_new_list_of_methods(gf, method); 
  790.   return method;
  791. }
  792.  
  793. /******************************************************************************
  794.  *
  795.  * A simple make (which will be redefined later in Scheme)
  796.  * This version handles only creation of gf, methods and classes (no instances)
  797.  *
  798.  * Since this code will disappear when Stklos will be fully booted, 
  799.  * no precaution is taken to be efficient.
  800.  *
  801.  ******************************************************************************/
  802.  
  803. static char k_name[]          = ":name";        /* Use vars since makekey patches */
  804. static char k_specializers[] = ":specializers"; /* its argument. This avoids the */
  805. static char k_procedure[]    = ":procedure";    /* -fwritable_string */
  806. static char k_dsupers[]         = ":dsupers";
  807. static char k_slots[]         = ":slots";
  808. static char k_gf[]         = ":generic-function";
  809.  
  810. static PRIMITIVE lmake(SCM args, int len)
  811. {
  812.   SCM classe, z;
  813.  
  814.   if (len == 0) Err("make: parameter list is null", NIL);
  815.  
  816.   classe = CAR(args); args  = CDR(args); 
  817.   
  818.   if (classe == Generic) {
  819.     z = make_instance(classe,
  820.               STk_llength(THE_SLOT_OF(classe, S_slots)), 
  821.               TYPE_GENERIC);
  822.  
  823.     THE_SLOT_OF(z, S_name)    = STk_get_keyword(STk_makekey(k_name), args, 
  824.                         Intern("???"));
  825.     THE_SLOT_OF(z, S_methods) = NIL;
  826.   }
  827.   else {
  828.     z = make_instance(classe, 
  829.               STk_llength(THE_SLOT_OF(classe, S_slots)), TYPE_INSTANCE);
  830.  
  831.     if (classe == Method) {
  832.       THE_SLOT_OF(z, S_generic_function) =  
  833.             STk_get_keyword(STk_makekey(k_gf), args, Ntruth);
  834.       THE_SLOT_OF(z, S_specializers) =  
  835.             STk_get_keyword(STk_makekey(k_specializers), args, NIL);
  836.       THE_SLOT_OF(z, S_procedure) =
  837.             STk_get_keyword(STk_makekey(k_procedure), args, NIL);
  838.     }
  839.     else {
  840.       /* In all the others case, make a new class .... No instance here */
  841.       THE_SLOT_OF(z, S_name) = 
  842.             STk_get_keyword(STk_makekey(k_name), args, Intern("???"));
  843.       THE_SLOT_OF(z, S_direct_supers) = 
  844.             STk_get_keyword(STk_makekey(k_dsupers), args, NIL);
  845.       THE_SLOT_OF(z, S_direct_slots)  = 
  846.             STk_get_keyword(STk_makekey(k_slots), args, NIL);
  847.     }
  848.   }
  849.   return z;
  850. }
  851.  
  852. static PRIMITIVE find_method(SCM l, int len)
  853. {
  854.   SCM gf;
  855.   
  856.   if (len == 0) Err("find-method: no parameter list", NIL);
  857.  
  858.   gf = CAR(l); l = CDR(l);
  859.   if (NGENERICP(gf)) Err("find-method: bad generic function", gf);
  860.   if (NULLP(THE_SLOT_OF(gf, S_methods))) 
  861.     Err("find-method: no methods for generic", gf);
  862.  
  863.   return STk_compute_applicable_methods(gf, l, len-1, TRUE);
  864. }
  865.  
  866. static PRIMITIVE user_more_specificp(SCM m1, SCM m2, SCM targs)
  867. {
  868.   char *msg1 = "%method-more-specific?: bad method";
  869.   char *msg2 = "%method-more-specific?: bad argument";
  870.   SCM l, v;
  871.   int i, len;
  872.  
  873.   if (NMETHODP(m1))           STk_err(msg1, m1);
  874.   if (NMETHODP(m2))           STk_err(msg1, m2);
  875.   if ((len=STk_llength(targs)) < 0) STk_err(msg2, targs);
  876.  
  877.   /* Verify that all the arguments of targs are classes and place them in a vector*/
  878.   v = STk_makevect(len, NULL);
  879.  
  880.   for (i=0, l=targs; NNULLP(l); i++, l=CDR(l)) {
  881.     if (NCLASSP(CAR(l))) STk_err(msg2, targs);
  882.     VECT(v)[i] = CAR(l);
  883.   }
  884.   return more_specificp(m1, m2, VECT(v)) ? Truth: Ntruth;
  885. }
  886.   
  887.   
  888.  
  889. /******************************************************************************
  890.  *
  891.  * Initializations 
  892.  *
  893.  ******************************************************************************/
  894.  
  895. static void make_stdcls(SCM *var, char *name, SCM meta, SCM super, SCM slots)
  896. {
  897.    SCM tmp = Intern(name);
  898.    
  899.    *var = STk_basic_make_class(meta, tmp, LIST1(super), slots);
  900.    STk_gc_protect(var);
  901.    VCELL(tmp) = *var;
  902. }
  903.  
  904. static void make_standard_classes(void)
  905. {
  906.   SCM tmp1 = LIST3(Intern("generic-function"), 
  907.            Intern("specializers"), 
  908.            Intern("procedure"));
  909.   SCM tmp2 = LIST2(Intern("name"), 
  910.            Intern("methods"));
  911.  
  912.   /* Generic functions classes */
  913.   make_stdcls(&Procedure_class, "<procedure-class>", Class, Class,          NIL);
  914.   make_stdcls(&Entity_class,    "<entity-class>",    Class, Procedure_class, NIL);
  915.   make_stdcls(&Method,        "<method>",         Class, Object,         tmp1);
  916.   make_stdcls(&Generic,        "<generic>",         Entity_class, Object,   tmp2);
  917.  
  918.   /* Primitive types classes */
  919.   make_stdcls(&Boolean,     "<boolean>",    Class,          Top,         NIL);
  920.   make_stdcls(&Char,        "<char>",    Class,          Top,        NIL);
  921.   make_stdcls(&List,        "<list>",    Class,          Top,        NIL);
  922.   make_stdcls(&Pair,        "<pair>",    Class,          List,        NIL);
  923.   make_stdcls(&Null,        "<null>",     Class,          List,        NIL);
  924.   make_stdcls(&String,        "<string>",    Class,          Top,        NIL);
  925.   make_stdcls(&Symbol,        "<symbol>",    Class,          Top,        NIL);
  926.   make_stdcls(&Vector,        "<vector>",    Class,          Top,        NIL);
  927.   make_stdcls(&Number,        "<number>",    Class,         Top,        NIL);
  928.   make_stdcls(&Real,        "<real>",    Class,          Number,    NIL);
  929.   make_stdcls(&Integer,        "<integer>",    Class,          Real,        NIL);
  930.   make_stdcls(&Keyword,        "<keyword>",    Class,          Top,        NIL);
  931.   make_stdcls(&Unknown,        "<unknown>",    Class,          Top,        NIL);
  932.   make_stdcls(&Procedure,    "<procedure>",    Procedure_class, Top,         NIL);
  933. #ifdef USE_TK
  934.   make_stdcls(&Widget,        "<widget>",    Procedure_class, Procedure, NIL);
  935. #endif
  936. }  
  937.  
  938. PRIMITIVE STk_init_STklos(void)
  939. {
  940.   STk_disallow_sigint();
  941.  
  942.   Top = Object = Class = Generic = Method = NIL;
  943.   create_Top_Object_Class();
  944.   make_standard_classes();
  945.  
  946.   /* Define new primitives */
  947.   STk_add_new_primitive("stklos-version",     tc_subr_0, stklos_version);
  948.   STk_add_new_primitive("instance?",              tc_subr_1, instancep);
  949.   STk_add_new_primitive("slot-ref",         tc_subr_2, STk_slot_ref);
  950.   STk_add_new_primitive("slot-set!",             tc_subr_3, STk_slot_set);
  951.   STk_add_new_primitive("slot-bound?",             tc_subr_2, slot_boundp);
  952.  
  953.   STk_add_new_primitive("class-of",         tc_subr_1, STk_class_of); 
  954.   STk_add_new_primitive("class-name",             tc_subr_1, class_name);
  955.   STk_add_new_primitive("class-direct-supers",   tc_subr_1, class_direct_supers);
  956.   STk_add_new_primitive("class-direct-slots",    tc_subr_1, class_direct_slots);
  957.   STk_add_new_primitive("class-precedence-list", tc_subr_1, class_cpl);
  958.   STk_add_new_primitive("class-slots",             tc_subr_1, class_slots);
  959.   STk_add_new_primitive("slot-exists?",             tc_subr_2, slot_existsp);
  960.  
  961.   STk_add_new_primitive("%allocate-instance",    tc_subr_1, STk_allocate_instance);
  962.   STk_add_new_primitive("%initialize-object",    tc_subr_2, initialize_object);
  963.   STk_add_new_primitive("%compute-slots",     tc_subr_1, compute_slots);
  964.   STk_add_new_primitive("%compute-initializers", tc_subr_1, build_initializers);
  965.   STk_add_new_primitive("%modify-instance",     tc_subr_2, modify_instance);
  966.   
  967.  
  968.   STk_add_new_primitive("add-method",           tc_subr_2, add_method);
  969.   STk_add_new_primitive("make",                tc_lsubr,  lmake);
  970.   STk_add_new_primitive("find-method",          tc_lsubr,  find_method);
  971.   STk_add_new_primitive("%method-more-specific?", tc_subr_3, user_more_specificp);
  972.  
  973.   STk_allow_sigint();
  974.   
  975.   return UNDEFINED;
  976. }
  977. #else 
  978.   /* Don't produce an empty object file since some compiler (loader?) don't 
  979.    * manage them corrctly 
  980.    */
  981.   static char not_used = '?';
  982. #endif
  983.